home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / S-EXPR.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  4.1 KB  |  128 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; s-expression manipulating functions
  3.  
  4. (require 'apl)
  5. (require 'sequence)
  6. (provide 's-expression)
  7.  
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ; addprop
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. (defun addprop (id new-value property)
  13.   (putprop id (cons new-value (get id property)) property))
  14.  
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ; adjoin
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (defun adjoin (thing list &key (test #'eql))
  20.   (if (member thing list :test test)
  21.       list
  22.       (cons thing list)))
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ; adjoin-to-end
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. (defun adjoin-to-end (new l &key (test #'eql))
  29.   (if (member new l :test test)
  30.       l
  31.     (cons-to-end new l)))
  32.  
  33. (defun cons-to-end (new l) (append l (list new)))
  34.  
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ; every-other
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38.  
  39. (defun every-other (list)
  40.   (if list
  41.     (cons (car list) (every-other (cddr list)))))
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44. ; plist-names
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46.  
  47. (defun plist-names (plist) (every-other plist))
  48.  
  49. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50. ; plist-values
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52.  
  53. (defun plist-values (plist) (every-other (cdr plist)))
  54.  
  55. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56. ; filter
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58.  
  59. (defun filter (l pred)
  60.   (if l
  61.       (let ((head (car l)))
  62.            (if (funcall pred head)
  63.                (cons head (filter (cdr l) pred))
  64.                (filter (cdr l) pred)))))
  65.  
  66. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  67. ; character-to-string
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69.  
  70. (defun character-to-string (c)
  71.   (let ((s (make-string-output-stream)))
  72.     (princ c s)
  73.     (get-output-stream-string s)))
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ; explode
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (defun explode (sym)
  80.   (let ((str (symbol-name sym)))
  81.     (mapcar #'intern
  82.       (mapcar #'character-to-string
  83.     (flet ((access (n) (char str n)))
  84.       (mapcar #'access (iota (length str))))))))
  85.  
  86. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87. ; one-of
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89.  
  90. (defun one-of (l) (nth (random (length l)) l))
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ; copy-tree
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95.  
  96. (defmacro copy-tree (x) `(subst nil nil ,x))
  97.  
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99. ; make-nth-first
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101.  
  102. (defun make-nth-first (n list)
  103.   (if (= n 0)
  104.     list
  105.     (cons (nth n list) (remove-nth-element n list))))
  106.  
  107. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  108. ; remove-nth-element
  109. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  110.  
  111. (defun remove-nth-element (n list)
  112.   (if (= n 0)
  113.     (cdr list)
  114.     (cons (car list) (remove-nth-element (1- n) (cdr list)))))
  115.  
  116.  
  117. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  118. ; select 
  119. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  120.  
  121. (defun select (seq indices)        ;Same order of arguments as elt
  122.   (if indices
  123.       (if (atom indices)
  124.       (list (elt seq indices))
  125.     (cons (elt seq (car indices))
  126.           (select seq (cdr indices))))))
  127.  
  128.